perm filename BIN[G,BGB]1 blob
sn#032397 filedate 1973-06-26 generic text, type T, neo UTF8
00100 TITLE BIN BODY INTERSECTION - 7 MARCH 1973.
00200
00300 EXTERN VCW,VCCW,ECCW,VERIFY
00400 EXTERN FACOEF,ESPLIT,INVERT
00500 EXTERN GLUEE,LINKED,MKEV,MKFE
00600 EXTERN MKB,MKF,MKV,MKFRAME
00700 EXTERN OTHER,EVERT,FCCW,FCW
00800 EXTERN DPYBUF,DPYSET,DPYOUT
00900 EXTERN FDPY,EDPY,VDPY
01000
01100 ↓SURBIT←←1B2 ;VERTEX ON SURFACE.
01200 ↓OKBIT←←2B2
01300
01400 DEFINE QFACE(Q,V){CDR Q,7(V)}
01500 DEFINE QFACE.(Q,V){DAP Q,7(V)}
01600
01700 DEFINE NAF (Q,E){CAR Q,-1(E)}
01800 DEFINE NAF.(Q,E){DIP Q,-1(E)}
01900
02000 DEFINE PAF (Q,E){CDR Q,-1(E)}
02100 DEFINE PAF.(Q,E){DAP Q,-1(E)}
02200
02300 DEFINE JALT(A,B){ALT. A,B↔ALT. B,A}
02400 DEFINE JALTV(V,V.){ALT. V,V.↔ALT. V.,V
02500 SLACI XWC(V)↔LAPI XWC(V.)↔BLT ZWC(V.)}
02600
02700 DECLARE{FNEXT,ENEXT}
00100 comment/
00200
00300 Although this code performs body union and body subtraction;
00400 all the nomensclature will be in terms of body intersection, BIN.
00500 Pure BIN takes two operand bodies and "copies" off them a resultant
00600 body of their intersection. This requires marking and splitting some
00700 of faces and edges, however the operand bodies can be restored to
00800 their original selves by applying KLTMPS; or if the operands are no
00900 longer needed they must be explicitly killed.
01000
01100 1. Face-Edge Compare; Make piercing vertices.
01200
01300 All the faces of each operand is compared with all the edges
01400 of the other. When a edge passes thru a face, the edge is spilt and
01500 a "surface vertex" or "SURV" is placed at the piercing point. The
01600 QFACE of the SURV points at the face pierce.
01700
01800 2. Face Hole Suppression.
01900
02000 3. Body and Face Tracing.
02100
02200 4. Dealing with bodies of parts.
02300
02400 5. Convex face making.
02500
02600
02700 LINKS LEFT BY BIN.
02800
02900 ALT of all result vertices points to a vertex in one or the
03000 other operand. ALT of a result edge is zero, if the edge was formed
03100 by two conflicting faces in the operands, the particular faces are
03200 pointed at by the NAF and PAF links. A non-zero ALT of a result edge,
03300 points at an edge of one operand that was buried inside the solid
03400 body of the other operand, and is thus called an interior edge.
03500 ALT of all faces of the result points at the corresponding face of
03600 one of the operands.
03700
03800 /
00100 SUBR(WITH3D)FACE,XWC,YWC,ZWC--------------------------------------
00200 BEGIN WITH3D; TEST FOR LOCUS WITHIN FACE 3D.
00300 ACCUMULATORS{FLG,V,E,F,DX1,DY1,DZ1,Q1,DX2,DY2,DZ2,Q2,E0}
00400
00500 ;SELECT COMPONENT BY LARGEST FACE COEFFICIENT.
00600 LAC F,ARG4
00700 LACM 1,AA(F)
00800 LACM 2,BB(F)
00900 LACM 3,CC(F)
01000 LACI C0↔CAMG 1,2↔GO[
01100 LACI C1↔CAMG 2,3↔LACI C2↔GO .+3]
01200 CAMG 1,3↔LACI C2↔DAP CASE
01300
01400 ;FIRST EDGE OF THE FACE.
01500 DOM FLG
01600 PED E,F↔DAC E,E0↔SETQ(V,{VCW,E,F})
01700 LAC DX2,XWC(V)↔FSB DX2,ARG3
01800 LAC DY2,YWC(V)↔FSB DY2,ARG2
01900 LAC DZ2,ZWC(V)↔FSB DZ2,ARG1
02000
02100 L1: LAC DX1,DX2
02200 LAC DY1,DY2
02300 LAC DZ1,DZ2
02400 LAC Q1,Q2
02500
02600 ;NEXT EDGE OF THE FACE.
02700 SETQ(V,{VCCW,E,F})
02800 SETQ(E,{ECCW,E,F})
02900 LAC DX2,XWC(V)↔FSB DX2,ARG3
03000 LAC DY2,YWC(V)↔FSB DY2,ARG2
03100 LAC DZ2,ZWC(V)↔FSB DZ2,ARG1
03200
03300 ;COMPUTE A COMPONENT OF THE CROSS-PRODUCT.
03400
03500 CASE: GO
03600 C0: LAC 0,DY2↔FMP 0,DZ1↔LAC 1,DY1↔FMP 1,DZ2↔GO C3
03700 C1: LAC 0,DX1↔FMP 0,DZ2↔LAC 1,DX2↔FMP 1,DZ1↔GO C3
03800 C2: LAC 0,DX2↔FMP 0,DY1↔LAC 1,DX1↔FMP 1,DY2
03900 C3: FSB 0,1↔DAC Q2
04000
04100 ;DETECT SIGN CHANGE.
04200
04300 AOJE FLG,.+3
04400 XOR Q1↔JUMPL POP4J. ;NO SKIP RETURN FALSE.
04500 CAME E,E0↔GO L1
04600 AOS(P)↔POP4J ;SKIP RETURN TRUE.
04700 BEND WITH3D;BGB 7 MARCH 73----------------------------------------
00100 SUBR(COMPFE)FACE,EDGE---------------------------------------------
00200 BEGIN COMPFE; COMPARE FACE EDGE 3D FOR PIERCING.
00300
00400 ACCUMULATORS{X,Y,Z,V1,V2,E,F}
00500
00600 ;CHECK ARGUMENTS FOR FRESHNESS.
00700 LAC E,ARG1↔LAC F,ARG2
00800 NVT V1,E↔PVT V2,E
00900 QFACE 1,V1↔CAMN 1,F↔POP0J
01000 QFACE 1,V2↔CAMN 1,F↔POP0J
01100
01200 ;DIRECTED DISTANCE V1 FROM FACE.
01300 LAC 0,AA(F)↔FMP 0,XWC(V1)
01400 LAC 1,BB(F)↔FMP 1,YWC(V1)↔FAD 0,1
01500 LAC 1,CC(F)↔FMP 1,ZWC(V1)↔FAD 0,1↔DAC Q1#
01600
01700 ;DIRECTED DISTANCE V2 FROM FACE.
01800 LAC 0,AA(F)↔FMP 0,XWC(V2)
01900 LAC 1,BB(F)↔FMP 1,YWC(V2)↔FAD 0,1
02000 LAC 1,CC(F)↔FMP 1,ZWC(V2)↔FAD 0,1↔DAC Q2#
02100
02200 ;DOES EDGE PASS THRU THE PLANE OF THIS FACE.
02300 LAC KK(F)
02400 CAMG Q1↔GO .+3↔CAMLE Q2↔POP0J
02500 CAML Q1↔GO .+3↔CAMGE Q2↔POP0J
02600 FSB 0,Q1↔LAC 1,Q2↔FSB 1,Q1
02700 FDVR 0,1↔SKIPL↔CAMLE[1.0]↔POP0J↔DAC 1
02800
02900 ;SOLVE FOR PLANE PIERCING LOCUS.
03000 LAC X,XWC(V1)↔LAC XWC(V2)↔FSB X↔FMP 1↔FADM X
03100 LAC Y,YWC(V1)↔LAC YWC(V2)↔FSB Y↔FMP 1↔FADM Y
03200 LAC Z,ZWC(V1)↔LAC ZWC(V2)↔FSB Z↔FMP 1↔FADM Z
03300 CALL(WITH3D,F,X,Y,Z)↔POP0J
03400 LAC E,ARG1↔LAC F,ARG2↔ADD P,[XWD 4,4]
03500
03600 ;MAKE FACE PIERCING POINT.
03700 LAC KK(F)↔CAMLE Q1↔GO[CALL(INVERT,E)↔GO .+1]
03800 CALL(ESPLIT,E)↔MARK 1,SURBIT
03900 POP P,ZWC(1)↔POP P,YWC(1)↔POP P,XWC(1)↔POP P,0
04000 QFACE. 0,1↔LAC 2,ARG1↔PED. 2,1↔POP0J
04100 COMMENT .
04200 V2 ← PVT ⊗ Q2 < K ABOVE F,
04300 | ENEW
04400 ____|_____________________
04500 / | /
04600 / ⊗ V FACE F /
04700 /_________________________/
04800 |
04900 | E
05000 V1 ← NVT ⊗ Q1 > K BELOW-F.
05100 BEND COMPFE;BGB 7 MARCH 73----------------------------------------
00100 SUBR(VNEXT)F,E.,V-------------------------------------------------
00200 BEGIN VNEXT
00300 ACCUMULATORS{F,E.,V}
00400 LAC F,ARG3
00500 LAC E.,ARG2
00600 LAC V,ARG1
00700
00800 ;INTERIOR TO INTERIOR.
00900 ALT 1,E.↔DAC 1,ENEXT
01000 TEST V,SURBIT↔GO[ ;SKIP WHEN VERTEX ON SURFACE.
01100 SETQ(ENEXT,{ECCW,ENEXT,F})
01200 CALL(VCCW,ENEXT,F)↔POP3J]
01300
01400 ;SURFACE TO INTERIOR.
01500 QFACE 0,V↔DAC 0,FNEXT
01600 CAME F,FNEXT↔JUMPE 1,[
01700 PED 1,V↔DAC 1,ENEXT
01800 CALL(OTHER,1,V)↔POP3J]
01900
02000 ;INTERIOR TO SURFACE.
02100 DZM ENEXT↔CAME F,FNEXT↔GO[
02200 CALL(OTHERV,F,V)↔POP3J]
02300
02400 ;SURFACE TO SURFACE.
02500 PAF 1,E.↔CAMN 1,F↔NAF 1,E.
02600 PED 0,V↔CALL(OTHER,0,1)↔DAC 1,FNEXT
02700 CALL(OTHERV,FNEXT,V)↔POP3J
02800 BEND VNEXT;BGB 8 MARCH 1973 --------------------------------------
00100 SUBR(OTHERV)F,V1 -------------------------------------------------
00200 BEGIN OTHERV
00300 ACCUMULATORS{F1,F2,V1,E,E0}
00400 LAC F2,ARG2
00500 LAC V1,ARG1
00600 QFACE F1,V1
00700
00800 ;DOES F1 PIERCE F2 AT V2.
00900 PED E,F1↔DAC E,E0
01000 L1: CALL(VCCW,E,F1)
01100 QFACE 0,1
01200 CAMN 0,F2↔POP2J
01300 SETQ(E,{ECCW,E,F1})
01400 CAME E,E0↔GO L1
01500
01600 ;DOES F2 PIERCE F1 AT V2.
01700 PED E,F2↔DAC E,E0
01800 L2: CALL(VCCW,E,F2)
01900 CAMN 1,V1↔GO .+4
02000 QFACE 0,1
02100 CAMN 0,F1↔POP2J
02200 SETQ(E,{ECCW,E,F2})
02300 CAME E,E0↔GO L2
02400 FATAL(OTHERV)
02500
02600 COMMENT ; OTHER PIERCING VERTEX MANDALA
02700
02800 F1 PIERCES F2 AT V2 CASE. F2 PIERCES F1 AT V2 CASE.
02900 ______________ ________
03000 | | | |
03100 | F2 | | F2 |
03200 ______|......... | ______|........|_____
03300 | ↓ . | | ↓ ↓ |
03400 | F1 ⊗V1 ⊗V2 | | F1 ⊗V1 ⊗V2 |
03500 |_______________↑ | |_____________________|
03600 | | | |
03700 |______________| |________| ;
03800
03900 BEND OTHERV;BGB 8 MARCH 1973 -------------------------------------
00100 SUBR(BTRACE)V0 ---------------------------------------------------
00200 BEGIN BTRACE; TRACE THE BODY OF INTERSECTION STARTING FROM V0.
00300 GO L0
00400 ACCUMULATORS{B,F,F.,E,E.,V,V.,V0}
00500 DECLARE{BODYIN,FACE,FACE.,EDGE,EDGE.,VERT,VERT.,VERT0}
00600
00700 ;MAKE THE BODY NODE.
00800 L0: LAC 1,ARG1↔PED 1,1↔CCW 1,1 ;BODY OF V0.
00900 SETQ(BODYIN,{MKB,1})
01000 CALL(MKF,BODYIN)
01100 CALL(MKV,BODYIN)
01200 CALL(MKFRAME)
01300 LAC B,BODYIN
01400 FRAME. 1,B
01500
01600 ;FIRST EDGE OF THE BODY AND ALL ITS FRIENDS.
01700 LAC V0,ARG1
01800 PVT V.,B
01900 JALTV(V0,V.)
02000 PED E,V0
02100 SETQ(F,{FCCW,E,V0})
02200 PFACE F.,B
02300 JALT(F,F.)
02400 SETQ(V,{VCCW,E,F})
02500 LAC[XWD B,BODYIN]↔BLT VERT0 ;SAVE AC'S.
02600 SETQ(V.,{MKEV,F.,V.})↔DAC V.,VERT.
02700 LAC V,VERT↔LAC E,EDGE
02800 JALTV(V,V.)
02900 PED E.,V.↔DAC E.,EDGE.
03000 JALT(E,E.)
03100
00100 L1:
00200 SETQ(VERT,{VNEXT,FACE,EDGE.,VERT})
00300 CAME 1,VERT0↔GO L2
00400
00500 ;LAST VERTEX OF THE LAMINA.
00600 ALT 1,1↔SETQ(EDGE.,{MKFE,1,FACE.,VERT.})
00700 LAC E.,EDGE.
00800 SKIPE 1,ENEXT
00900 GO[JALT(1,E.)↔NFACE F.,E.↔DAC F.,FACE.↔GO L3]
01000 LAC 1,FNEXT↔PAF. 1,E.
01100 LAC F,FACE↔NAF. F,E.
01200 NFACE F.,E.↔DAC F.,FACE.↔GO L3
01300
01400 ;NEXT VERTEX OF THE LAMINA.
01500 L2: SETQ(VERT.,{MKEV,FACE.,VERT.})
01600 LAC V,VERT↔JALTV(V,1)
01700 PED E.,1↔DAC E.,EDGE.
01800 SKIPE 1,ENEXT
01900 GO[JALT(1,E.)↔GO L1]
02000 LAC F,FACE↔PAF. F,E.
02100 LAC 1,FNEXT↔NAF. 1,E.
02200 GO L1
02300
02400 L3: CALL(EVERT,BODYIN)
02500
02600 ;TRACE OUT ALL THE FACES CONNECTED TO THIS BODY.
02700 L4: LAC 1,FACE.
02800 TEST 1,FBIT
02900 GO[LAC 1,BODYIN↔POP1J] ;RETURN THE BODY.
03000 CALL(FTRACE,FACE.)
03100 LAC 1,FACE.
03200 PFACE 1,1
03300 DAC 1,FACE.
03400 GO L4
03500 BEND BTRACE;BGB 8 MARCH 1973 -------------------------------------
00100 SUBR(FTRACE)F. ---------------------------------------------------
00200 BEGIN FTRACE; FACE TRACE.
00300 GO L0
00400 DECLARE{F,F.,E,E.,V,V.,U,U.,V0,F2.}
00500
00600 ;GET THE FIRST EDGE AND ITS FRIENDS.
00700 L0: LAC 1,ARG1↔DAC 1,F.
00800 PED 1,1↔DAC 1,E.
00900 CALL(VCW,E.,F.)↔ALT 1,1↔DAC 1,V0
01000 CALL(VCCW,E.,F.)↔ALT 1,1↔DAC 1,V
01100 LAC 2,E.↔ALT 1,2↔DAC 1,E
01200 JUMPN 1,[
01300 CALL(OTHER,E.,F.)
01400 ALT 1,1
01500 CALL(OTHER,E,1)
01600 GO .+5]
01700 PAF 1,2↔PFACE 0,2
01800 CAME 0,F.↔NAF 1,2
01900 DAC 1,F↔LAC 2,F.
02000 JALT(1,2)
02100
02200 L1:
02300 LAC 1,V↔CAMN 1,V0↔POP1J ;EXIT.
02400 DAC 1,U
02500 SETQ(V,{VNEXT,F,E.,V})
02600 SETQ(E.,{ECCW,E.,F.})
02700 SETQ(V.,{VCCW,E.,F.})
02800
02900 ;MAKE SPUR.
03000 LAC 1,V↔ALT 1,1↔JUMPN 1,L2
03100 LAC 1,U↔ALT 1,1
03200 SETQ(V.,{MKEV,F.,1})
03300 LAC 2,V↔JALTV(2,1)
03400 PED 1,1↔DAC 1,E.
03500 SKIPE 2,ENEXT↔GO[JALT(2,1)↔GO L1]
03600 LAC 2,FNEXT↔NAF. 2,1
03700 LAC 2,F↔PAF. 2,1↔GO L1
03800
03900 ;SPLIT FACE.
04000 L2: CAMN 1,V.↔GO L1 ;SKIP V.≠ALT(V).
04100 CALL(LINKED,1,F.)
04200 JUMPE 1,L3 ;JUMP WHEN NOT LINKED.
04300
04400 LAC 1,V↔ALT 1,1
04500 LAC 2,U↔ALT 2,2
04600 SETQ(E.,{MKFE,2,F.,1})
04700 SKIPE 2,ENEXT↔GO[JALT(2,1)↔GO L1]
04800 LAC 2,FNEXT↔NAF. 2,1
04900 LAC 2,F↔PAF. 2,1↔GO L1
05000
00100 ;MAKE WASP FACE.
00200 L3: LAC 1,V↔ALT 1,1↔DAC 1,V.
00300 LAC 1,U↔ALT 1,1↔DAC 1,U.
00400 LAC 1,F.↔PFACE 1,1↔DAC 1,F2.
00500 JUMPE 1,[FATAL({WASP LINK F2.=0.})]
00600 SETQ(E.,{GLUEE,F.,U.,F2.,V.})
00700 SKIPE 2,ENEXT↔GO[JALT(2,1)↔GO L1]
00800 LAC 2,FNEXT↔PAF. 2,1
00900 LAC 2,F↔NAF. 2,1
01000 GO L1
01100 BEND FTRACE;BGB 8 MARCH 1973 -------------------------------------
00100 SUBR(BIN)B1,B2----------------------------------------------------
00200 BEGIN BIN; COMPUTE BODY OF INTERSECTION.
00300
00400 LAC 1,ARG2↔TEST 1,BBIT↔POP2J↔CALL(FACOEF,1,[0])
00500 LAC 1,ARG1↔TEST 1,BBIT↔POP2J↔CALL(FACOEF,1,[0])
00600 LAC 1,ARG2↔PVT 1,1↔TEST 1,VBIT↔GO .+3↔DZM ZPP(1)↔GO .-5
00700 LAC 1,ARG1↔PVT 1,1↔TEST 1,VBIT↔GO .+3↔DZM ZPP(1)↔GO .-5
00800
00900 ;COMPARE ALL THE EDGES OF ONE WITH ALL THE FACES OF THE OTHER.
01000 ;THIS N SQUARED PROCESS MAY SOMEDAY BE REPLACED WITH AN OCCULT MODE.
01100 LAC 1,ARG1
01200 L1: PED 1,1↔TEST 1,EBIT↔GO L2-1
01300 LAC 2,ARG2↔PFACE 2,2↔TESTZ 2,FBIT↔GO[
01400 CALL(COMPFE,2,1)↔POP P,1↔POP P,2↔GO .-3]↔GO L1
01500
01600 LAC 1,ARG2
01700 L2: PED 1,1↔TEST 1,EBIT↔GO L3
01800 LAC 2,ARG1↔PFACE 2,2↔TESTZ 2,FBIT↔GO[
01900 CALL(COMPFE,2,1)↔POP P,1↔POP P,2↔GO .-3]↔GO L2
02000
02100 L3: CALL(GETSURV,ARG1)↔GO L4
02200 CALL(GETSURV,ARG2)↔GO L4
02300 GO L5
02400
02500 L4: CALL(QHOLE,1) ;CHECK OUT A POTENTIAL HOLE.
02600 GO L3 ;NO HOLE YET.
02700 CALL(KLSURV,ARG1) ;HOLE FACE WAS PYRAMID'ED.
02800 CALL(KLSURV,ARG2) ;START OVER.
02900 GO BIN
03000 L5: LAC 1,ARG1
03100 NVT 1,1↔TESTZ 1,VBIT↔GO[
03200 TEST 1,SURBIT↔GO .-3
03300 ALT 0,1↔SKIPE↔GO .-3
03400 CALL(BTRACE,1,1)
03500 DAC 1,B#
03600 POP P,1↔GO .-3]
03700
03800 LAC 1,ARG2
03900 NVT 1,1↔TESTZ 1,VBIT↔GO[
04000 TEST 1,SURBIT↔GO .-3
04100 ALT 0,1↔SKIPE↔GO .-3
04200 CALL(BTRACE,1,1)
04300 POP P,1↔GO .-3]
04400
04500 LAC 1,B↔POP2J
04600
04700 BEND BIN;BGB 7 MARCH 73-------------------------------------------
00100 SUBR(SOLANG)V ----------------------------------------------------
00200 BEGIN SOLANG; SOLID ANGLE OF A SURFACE VERTEX.
00300 EXTERN ACOS,DISTANCE,TWOPI
00400 ACCUMULATORS{F,V}
00500
00600 LAC 1,ARG1↔DAC 1,V0
00700 PED 1,1↔DAC 1,E
00800 SETQ(F1,{FCCW,E,V0})↔SETQ(V1,{OTHERV,F1,V0})
00900 SETQ(F2,{FCW,E,V0})↔ SETQ(V2,{OTHERV,F2,V0})
01000
01100 CALL(DISTANCE,V1,V0)↔PUSH P,1 ;L1
01200 CALL(DISTANCE,V2,V0)↔PUSH P,1 ;L2
01300 CALL(DISTANCE,V1,V2)↔FMPR 1,1↔MOVNS 1 ;L3
01400
01500 ;ANGLE ← ACOS((L1*L1 + L2*L2 - L3*L3)/(2*L1*L2)).
01600 POP P,2↔POP P,3
01700 LAC 2↔FMPR 3↔FSC 1
01800 FMPR 2,2↔FMPR 3,3
01900 FADR 1,2↔FADR 1,3
02000 FDVR 1,0
02100 CALL(ACOS,1)↔PUSH P,1
02200
02300 LAC V,V2↔LAC F,F1
02400 LAC 0,XWC(V)↔FMPR 0,AA(F)
02500 LAC 1,YWC(V)↔FMPR 1,BB(F)↔FADR 0,1
02600 LAC 1,ZWC(V)↔FMPR 1,CC(F)↔FADR 0,1
02700 POP P,1
02800 CAML KK(F)↔POP1J↔MOVNS 1
02900 FADR TWOPI↔POP1J ;REFLEX ANGLE.
03000 DECLARE{V0,V1,V2,E,F1,F2}
03100 BEND SOLANG;BGB 23 MARCH 1972-------------------------------------
00100 SUBR(KLSURV)B ----------------------------------------------------
00200 BEGIN KLSURV; KILL SURFACE VERTICES OF A BODY.
00300 EXTERN KLEV
00400 ACCUMULATORS{V}
00500 LAC V,ARG1
00600 L: NVT V,V↔CAMN V,ARG1↔POP1J
00700 TEST V,SURBIT↔GO L
00800 NVT V,V↔PUSH P,V↔PVT V,V
00900 CALL(KLEV,V)↔POP P,V
01000 GO L+1
01100 BEND KLSURV;BGB 23 MARCH 1972-------------------------------------
01200
01300
01400 SUBR(OKSURV)V ----------------------------------------------------
01500 BEGIN OKSURV; MARK A SURFACE LOOP AND MAKE ITS LIST.
01600 V←←2
01700 LAC V,ARG1↔PED 1,V
01800 PFACE 1,1↔DAC 1,FACE# ;FACE BEGLONG TO V.
01900 QFACE 1,V↔DAC 1,OLDQF# ;FACE PIERCED BY V.
02000 L: MARK V,OKBIT↔PUSH P,V
02100 CALL(OTHERV,FACE,V) ;FOLLOW SURV LOOP ACROSS.
02200 POP P,V
02300 CAMN 1,ARG1↔GO[
02400 SETZ↔ALT2. 0,V↔POP1J] ;NIL AT END OF LIST.
02500 ALT2. 1,V↔DAC 1,V ;OLDE V POINTS AT NEW V.
02600 QFACE 0,V↔LAC 1,FACE ;NEXT FACE.
02700 CAME 0,OLDQF↔LAC 1,OLDQF
02800 DAC 0,OLDQF↔PED 0,V
02900 SETQ(FACE,{OTHER,0,1})
03000 GO L
03100 BEND OKSURV;BGB 23 MARCH 1973-------------------------------------
03200
03300
03400 SUBR(GETSURV)B ---------------------------------------------------
03500 BEGIN GETSURV; GET AN UNMARKED SURFACE VERTEX OF A BODY OR SKIP.
03600 LAC 1,ARG1
03700 L: NVT 1,1
03800 CAMN 1,ARG1
03900 GO[AOS(P)↔POP1J]
04000 TEST 1,SURBIT↔GO L
04100 TESTZ 1,OKBIT↔GO L
04200 POP1J
04300 BEND GETSURV;BGB 23 MARCH 1973------------------------------------
00100 SUBR(QHOLE)V------------------------------------------------------
00200 BEGIN QHOLE; DETECT AND PYRAMID POTENTIAL PIERCE HOLES.
00300 EXTERN PYRAMID,PI
00400 V←←2
00500 CALL(OKSURV,ARG1)
00600 ;SECOND TIME AROUND - LOOK FOR DIFFERENT Q-FACES.
00700 LAC V,ARG1
00800 QFACE 1,V↔DAC 1,QF#
00900 L1: ALT2 V,V↔JUMPE V,L2
01000 QFACE 0,V↔CAME 0,QF↔POP1J ;EXIT NO HOLE.
01100 GO L1
01200 L2: DZM A#↔DZM N#↔DZM X#↔DZM Y#↔DZM Z#
01300
01400 ;THIRD TIME AROUND - TAKE SUM OF SOLID INTERIOR ANGLES.
01500 LAC V,ARG1
01600 L3: LAC XWC(V)↔FADRM X
01700 LAC YWC(V)↔FADRM Y
01800 LAC ZWC(V)↔FADRM Z
01900 AOS N↔PUSH P,V
02000 CALL(SOLANG,V)↔FADRM 1,A
02100 POP P,V↔ALT2 V,V
02200 SKIPE V↔GO L3
02300
02400 LAC 0,N↔FLOAT↔DAC 0,N
02500 FSBRI(2.0)↔FMPR PI↔FSBR A
02600 L4: MOVMS↔CAMGE[0.01]↔POP1J ;EXIT - NO HOLE.
02700 CALL(PYRAMID,QF)
02800 LAC X↔FDVR N↔DAC XWC(1)
02900 LAC Y↔FDVR N↔DAC YWC(1)
03000 LAC Z↔FDVR N↔DAC ZWC(1)
03010 PED 2,1↔DAC 2,3↔DAC 1,4
03020 L5: MARK 2,DARKEN↔SETQ(2,{ECCW,2,4})↔CAME 2,3↔GO L5
03100 AOS(P)↔POP1J ;SKIP EXIT - HOLE.
03200 BEND QHOLE; 23 MARCH 1973 ----------------------------------------
00100 SUBR(BUN)B1,B2----------------------------------------------------
00200 BEGIN BUN;BODY UNION.
00300 CALL(EVERT,ARG1)
00400 CALL(EVERT,ARG2)
00500 CALL(BIN,ARG2,ARG2)
00600 PUSH P,1
00700 CALL(EVERT,1)
00800 POP P,1
01000 POP2J
01100 BEND BUN;BGB 10 MARCH 1973----------------------------------------
01200
01300 SUBR(BSUB)B1,B2---------------------------------------------------
01400 BEGIN BSUB; BODY SUBTRACTION BNEW ← B1 - B2.
01500 CALL(EVERT,ARG1)
01600 CALL(BIN,ARG2,ARG2)
01800 POP2J
01900 BEND BSUB;BGB 10 MARCH 1973---------------------------------------
00100 SUBR(MKCVEX)F ----------------------------------------------------
00200 BEGIN MKCVEX; MAKE FACES CONVEX.
00300 EXTERN MKFE,KLFE,ECOEF,VCCW,QFEV,ECW
00400 ACCUMULATORS{F,E0,V,CNT,N,S,E,W,YMAX,YMIN,XMAX,XMIN}
00500 ; CALL(GEODPY)↔EXTERN GEODPY
00600
00700 ;GET EXTREMA VERTICES.
00800 LAC F,ARG1↔DAC F,FACE1
00810 TEST F,BBIT↔GO L0
00820 L00: PFACE F,F↔CAMN F,ARG1↔POP1J
00830 PUSH P,F↔CALL(MKCVEX,F)↔POP P,F↔GO L00
00900 L0: PED E0,F↔DAC E0,EDGE0
01000 LACI CNT,1
01100 SLACI YMAX,400000
01200 SLACI XMAX,400000
01300 SETCM YMIN,YMAX
01400 SETCM XMIN,XMAX
01500
01600 L1: SETQ(V,{VCCW,E0,F})
01700 CAMGE YMAX,YPP(V)↔GO[LAC YMAX,YPP(V)↔LAC N,V↔GO .+1]
01800 CAMGE XMAX,XPP(V)↔GO[LAC XMAX,XPP(V)↔LAC E,V↔GO .+1]
01900 CAMLE YMIN,YPP(V)↔GO[LAC YMIN,YPP(V)↔LAC S,V↔GO .+1]
02000 CAMLE XMIN,XPP(V)↔GO[LAC XMIN,XPP(V)↔LAC W,V↔GO .+1]
02100 SETQ(E0,{ECCW,E0,F})
02200 CAME E0,EDGE0↔AOJA CNT,L1
02300
02400 ;EXIT IF FACE1 IS ALREADY A TRIANGLE.
02500 L1B: CAIN CNT,3↔POP1J
00100 GO L6
00200
00300 ;LOP OFF THE POINT WITH THE SMALLEST ANGLE ≡ LARGEST COSINE.
00400 L5: LAC V,ARG1↔DAC V,VERT2
00500 SETQ(EDGE1,{ECCW,VERT2,FACE1})
00600 PVT 0,1↔CAMN 0,V↔GO .+3
00700 CALL(INVERT,1)↔NVT 0,1↔DAC VERT3
00800 SETQ(EDGE3,{ECW,VERT2,FACE1})
00900 PVT 0,1↔CAMN 0,V↔GO .+3
01000 CALL(INVERT,1)↔NVT 0,1↔DAC VERT1
01100 CALL(ECOEF,EDGE1)
01200 CALL(ECOEF,EDGE3)
01300 LAC 2,EDGE1↔LAC 3,EDGE3
01400 LAC 1,AA(2)↔FMPR 1,AA(3)
01500 LAC 0,BB(2)↔FMPR 0,BB(3)↔FADR 1,0
01600 LAC 0,ARG1
01700 POP1J
01800
01900 L6: CALL(,N,S,E,W)
02000 SETZM TMP
02100 CALL(L5)↔CAMGE 1,TMP↔GO .+3↔DAC VERT0↔DAC 1,TMP
02200 CALL(L5)↔CAMGE 1,TMP↔GO .+3↔DAC VERT0↔DAC 1,TMP
02300 CALL(L5)↔CAMGE 1,TMP↔GO .+3↔DAC VERT0↔DAC 1,TMP
02400 CALL(L5)↔CAMGE 1,TMP↔GO .+3↔DAC VERT0↔DAC 1,TMP
02500 CALL(L5,VERT0)
02600
02700 SETQ(EDGE2,{MKFE,VERT1,FACE1,VERT3})
02750 MARK 1,DARKEN
02800 NFACE 1,1↔DAC 1,FACE2
02900 CALL(ECOEF,EDGE2)
00100 ;SCAN FACE1'S PERIMETER VERT1 TO VERT3.
00200 DZM QMAX↔DZM VERT4
00300 LAC EDGE2↔DAC EDGE0
00310 LAC 1,EDGE1↔PFACE 0,1↔CAME 0,FACE2↔GO[
00320 CALL(INVERT,EDGE1)↔GO .+1]
00350 LAC 1,EDGE3↔PFACE 0,1↔CAME 0,FACE2↔GO[
00360 CALL(INVERT,EDGE3)↔GO .+1]
00400 L2: SETQ(EDGE0,{ECCW,EDGE0,FACE1})
00500 SETQ(VERT0,{VCCW,EDGE0,FACE1})
00600 CAMN 1,VERT1↔GO L3
00700
00800 ;TEST FOR VERTEX WITHIN THE TRIANGLE THAT WE ARE ABOUT TO LOP.
00900 CALL(QFEV,FACE2,EDGE2,VERT0)↔JUMPL 1,L2↔DAC 1,TMP
01200 CALL(QFEV,FACE2,EDGE1,VERT0)↔JUMPL 1,L2
01500 CALL(QFEV,FACE2,EDGE3,VERT0)↔JUMPL 1,L2
01600
01700 ;FIND VERTEX WITHIN TRIANGLE, FURTHEST FROM EDGE2.
01800 LACM 1,TMP↔CAMG 1,QMAX↔GO L2
01900 DAC 1,QMAX↔LAC VERT0↔DAC VERT4↔GO L2
02000
02100 ;WHEN TRIANGLE IS UNVIOLATED THEN ITERATE.
02200 L3: SKIPE VERT4↔GO L4
02300 GO MKCVEX
02400
02500 ;WHEN TRIANGLE HAS BEEN VIOLATED THEN RECURSE.
02600 L4: CALL(KLFE,EDGE2)
02700 CALL(MKFE,VERT2,FACE1,VERT4)
02750 MARK 1,DARKEN
02800 NFACE 1,1 ;START WORKING ON THE NEW FACE.
02900 CALL(MKCVEX,1)
03000 GO MKCVEX ;CONTINUE WORKING ON THE OLDE FACE.
03100
03200 DECLARE{FACE1,FACE2,TMP,QMAX}
03300 DECLARE{EDGE0,EDGE1,EDGE2,EDGE3}
03400 DECLARE{VERT0,VERT1,VERT2,VERT3,VERT4}
03500 BEND MKCVEX;BGB 23 MARCH 1973-------------------------------------
03600 END